home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / perl5.tcl < prev    next >
Text File  |  1997-03-06  |  8KB  |  240 lines
  1.  
  2. ##############################################################################
  3. # Colorization and cmd-dbl-click support for Perl 5
  4. #
  5. # Author: Tom Pollard <pollard@chem.columbia.edu>
  6. # Last modified: 1/1/96
  7. #
  8. # if {![info exists perlDocs]} {
  9. #     set perlDocs "$HOME:Help:Perl Docs"
  10. # }
  11.  
  12. ##############################################################################
  13. # Colorization setup
  14. #
  15. # Keywords are separated here according to their location in the Perl 5
  16. # documentation for the convenience of the cmd-double-click mechanism.
  17. #
  18. set perlKeyWords {}
  19.  
  20. # These are described in the "Compound statements" section of "perlsyn"
  21. #
  22. set words {  
  23.     continue else elsif for foreach if return unless until while 
  24.     eq ne cmp lt gt le ge
  25. }
  26. foreach wd $words { 
  27.     set perlLookup($wd) [list perlsyn {Compound statements}] 
  28. }
  29. set perlKeyWords [concat $perlKeyWords $words]
  30.  
  31. # These are described in the "SYNOPSIS" section of "perlsub"
  32. #
  33. set words { sub }
  34. foreach wd $words { set perlLookup($wd) [list perlsub {SYNOPSIS}] }
  35. set perlKeyWords [concat $perlKeyWords $words]
  36.  
  37. # These are described in the "Packages" section of "perlmod"
  38. #
  39. set words { package }
  40. foreach wd $words { set perlLookup($wd) [list perlmod {Packages}] }
  41. set perlKeyWords [concat $perlKeyWords $words]
  42.  
  43. # These are described in the "Package Constructors and Destructors" 
  44. # section of "perlmod" and can't be colorized.
  45. #
  46. set words { BEGIN END }
  47. foreach wd $words { 
  48.     set perlLookup($wd) [list perlmod {Package Constructors and Destructors}] 
  49. }
  50.  
  51. # These are described in the "A Class is Simply a Package" 
  52. # section of "perlobj" and can't be colorized.
  53. #
  54. set words { @ISA $ISA }
  55. foreach wd $words { 
  56.     set perlLookup($wd) [list perlobj {A Class is Simply a Package}] 
  57. }
  58.  
  59. # These are described in the "SYNOPSIS" section of "perlovl" and 
  60. # can't be colorized.
  61. #
  62. set words { %OVERLOAD $OVERLOAD }
  63. foreach wd $words { set perlLookup($wd) [list perlovl {SYNOPSIS}] }
  64.  
  65. # Special variables are described in "perlvar" (and are not all
  66. # individually marked, so we have to search for them.)
  67. #
  68. # This group can safely be colorized...
  69. #
  70. set words {
  71.     $_ $1 $2 $3 $4 $5 $6 $7 $8 $9 $& $` $' $+ $* $.  $/ $| $, $\\ $" $; $# $% 
  72.     $= $- $~ $^ $: $?  $!  $@ $$ $< $> $( $) $0 $[ $]
  73. }
  74. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  75. set perlKeyWords [concat $perlKeyWords $words]
  76.  
  77. #... while this group is forced lower-case by the current colorization scheme
  78. #
  79. set words {
  80.     $ARG $MATCH $PREMATCH $POSTMATCH $LAST_PAREN_MATCH $MULTILINE_MATCHING 
  81.     $INPUT_LINE_NUMBER $NR $INPUT_RECORD_SEPARATOR $RS $OUTPUT_AUTOFLUSH 
  82.     $OUTPUT_FIELD_SEPARATOR $OFS $OUTPUT_RECORD_SEPARATOR $ORS 
  83.     $LIST_SEPARATOR $SUBSCRIPT_SEPARATOR $SUBSEP $OFMT $FORMAT_PAGE_NUMBER 
  84.     $FORMAT_LINES_PER_PAGE $FORMAT_LINES_LEFT $FORMAT_NAME $FORMAT_TOP_NAME 
  85.     $FORMAT_LINE_BREAK_CHARACTERS $FORMAT_FORMFEED $^L $ACCUMULATOR $^A 
  86.     $CHILD_ERROR $OS_ERROR $ERRNO $EVAL_ERROR $PROCESS_ID $PID $REAL_USER_ID 
  87.     $UID $EFFECTIVE_USER_ID $EUID $REAL_GROUP_ID $GID $EFFECTIVE_GROUP_ID 
  88.     $EGID $PROGRAM_NAME $PERL_VERSION $DEBUGGING $^D $SYSTEM_FD_MAX $^F 
  89.     $INPLACE_EDIT $^I $PERLDB $^P $BASETIME $^T $WARNING $^W 
  90.     $EXECUTABLE_NAME $^X $ARGV @ARGV @INC %INC $INC $ENV $SIG %ENV %SIG
  91. }
  92. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  93.  
  94. # These are also described in "perlvar", despite being functions.
  95. #
  96. set words {
  97.     input_line_number input_record_separator autoflush 
  98.     output_field_separator output_record_separator format_page_number 
  99.     format_lines_per_page format_lines_left format_name format_top_name 
  100.     format_line_break_characters format_formfeed
  101. }
  102. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  103. set perlKeyWords [concat $perlKeyWords $words]
  104.  
  105.  
  106. # These are described in "perlfunc"
  107. #
  108. set words {
  109.     abs accept alarm atan2 bind binmode bless caller chdir chmod chomp 
  110.     chop chown chr chroot close closedir connect cos crypt dbmclose dbmopen 
  111.     defined delete die do dump each eof eval exec exists exit exp fcntl 
  112.     fileno flock fork formline getc getlogin getpeername getpgrp getppid 
  113.     getpriority getpwnam getgrnam gethostbyname getnetbyname getprotobyname 
  114.     getpwuid getgrgid getservbyname gethostbyaddr getnetbyaddr 
  115.     getprotobynumber getservbyport getpwent getgrent gethostent getnetent 
  116.     getprotoent getservent setpwent setgrent sethostent setnetent 
  117.     setprotoent setservent endpwent endgrent endhostent endnetent 
  118.     endprotoent endservent getsockname getsockopt glob gmtime goto grep hex 
  119.     import index int ioctl join keys kill last lc lcfirst length link listen 
  120.     local localtime log lstat m map mkdir msgctl msgget msgsnd msgrcv my 
  121.     next no oct open opendir ord pack pipe pop pos print printf push q qq qx 
  122.     qw quotemeta rand rand read readdir readlink recv redo ref rename 
  123.     require reset return reverse rewinddir rindex rmdir s scalar seek 
  124.     seekdir select select semctl semget semop send setpgrp setpriority 
  125.     setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep 
  126.     socket socketpair sort splice split sprintf sqrt srand stat study substr 
  127.     symlink syscall sysread system syswrite tell telldir tie time times tr 
  128.     truncate uc ucfirst umask undef unlink unpack untie unshift use utime 
  129.     values vec wait waitpid wantarray warn write y
  130. }
  131. foreach wd $words { set perlLookup($wd) [list perlfunc $wd] }
  132. set perlKeyWords [concat $perlKeyWords $words]
  133.  
  134. regModeKeywords -e {#} -c red -k blue -s [set PerlmodeVars(stringColor)] Perl $perlKeyWords
  135. unset perlKeyWords
  136.  
  137. set perlKeyWords [array names perlLookup]
  138.  
  139. ##############################################################################
  140. # Cmd-double-click support for Perl mode. (modified for Perl 5 doc structure)
  141. # 
  142. proc PerlDblClick {from to} {
  143.     global HOME perlKeyWords perlLookup perlDocs perlVersion
  144.     global perlSearchPath
  145.     
  146.     set pc  [lookAt [expr $from - 1]]
  147.     set ppc [lookAt [expr $from - 2]]
  148.     set tc  [lookAt $to]
  149.     
  150.     # Extend selection to include special characters
  151.     #
  152.     if {$pc == {$}} { 
  153.         if {$from == $to} { incr to }
  154.         incr from -1
  155.         if {$tc == {^}} { incr to }
  156.         
  157.     } elseif {$pc == {^} && $ppc == {$}} {
  158.         incr from -2
  159.         
  160.     } elseif {$pc == {%} || $pc == {@}} {
  161.         incr from -1
  162.     }
  163.     
  164.     # Return if there's no selected text
  165.     if {$to > $from} {
  166.         select $from $to
  167.         set text [getSelect]
  168.         set qtext [quoteExpr $text]
  169.     } else {
  170.         return
  171.     }
  172. #     alertnote "\"$text\""
  173.  
  174.     set perlSearchPath {}
  175.  
  176.     # Function call
  177.     if {$pc == "&"} {
  178.          if {![catch {search -f 1 -r 1 -m 0 -s "sub *$qtext *\{" 0} mtch]} {
  179.              pushMark
  180.              eval select $mtch
  181.              message "Use Ctl-. to return to original position"
  182.          } else {
  183.              message {Sub definition not found}
  184.          }
  185.  
  186.     # Look up keywords in the man page by their file marks
  187.     } elseif {[lsearch -exact $perlKeyWords $text] >= 0} {
  188.         set file [lindex $perlLookup($text) 0]
  189.         set mark [lindex $perlLookup($text) 1]
  190.         openFileQuietly "$perlDocs:$file"
  191.         podFindMark "$mark"
  192.     
  193.     # If user clicked the arg of a 'require' command, open the file
  194.     } elseif {![catch {perlFindRequire $from $to} filename]} {
  195.         openPerlFile $filename
  196.  
  197.     # Other
  198.     } else {
  199.         select $from $to
  200.         message {Command-double-click on keywords, special vars, and req'd filenames}
  201.     }
  202.  
  203. }
  204.  
  205. #############################################################################
  206. # These last two procs are duplicated from "pod.tcl", so that that file 
  207. # doesn't have to be loaded in order simply to reference the Perl 5 docs
  208. #
  209. proc podFindMark {mark} {
  210.     global podMarkIndent
  211.     set mark0 $mark
  212.     set marks [getNamedMarks -n]
  213.     regsub -all {[\/\(\)<>^]} $mark { } mark
  214.     set mark [quoteExpr3 $mark]
  215.     set item [lsearch -regexp $marks " *${mark}"]
  216.     if {$item >= 0} {
  217.         gotoMark [lindex $marks $item]
  218.     } elseif {![catch {search -f 1 -r 1 -i 0 -m 0 -s " *${mark}" 0} mtch]} {
  219.             goto [lindex $mtch 0]
  220.     } else {
  221.         message "Couldn't locate the section for \"$mark0\""
  222.     } 
  223. }
  224.  
  225. proc quoteExpr3 str {
  226.     regsub -all {\\} $str {\\\\} str
  227.     regsub -all {\|} $str {\|} str
  228.     regsub -all {\*} $str {\\*} str
  229.     regsub -all {\+} $str {\\+} str
  230.     regsub -all {\?} $str {\\?} str
  231.     regsub -all {\$} $str {\\$} str
  232.     regsub -all {\(} $str {\\(} str
  233.     regsub -all {\)} $str {\\)} str
  234.     regsub -all {\{} $str "\\\{" str
  235.     regsub -all {\}} $str "\\\}" str
  236.     regsub -all {\[} $str {\\[} str
  237.     regsub -all {\]} $str {\\]} str
  238.     return $str
  239. }
  240.